home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / srcuc.zip / ARTUTL.C < prev    next >
C/C++ Source or Header  |  1992-01-20  |  11KB  |  434 lines
  1. /* -*-C-*-
  2.  
  3. $Header: /scheme/src/microcode/RCS/artutl.c,v 1.8 1992/01/20 16:09:23 jinx Exp $
  4.  
  5. Copyright (c) 1989-92 Massachusetts Institute of Technology
  6.  
  7. This material was developed by the Scheme project at the Massachusetts
  8. Institute of Technology, Department of Electrical Engineering and
  9. Computer Science.  Permission to copy this software, to redistribute
  10. it, and to use it for any purpose is granted, subject to the following
  11. restrictions and understandings.
  12.  
  13. 1. Any copy made of this software must include this copyright notice
  14. in full.
  15.  
  16. 2. Users of this software agree to make their best efforts (a) to
  17. return to the MIT Scheme project any improvements or extensions that
  18. they make, so that these may be included in future releases; and (b)
  19. to inform MIT of noteworthy uses of this software.
  20.  
  21. 3. All materials developed as a consequence of the use of this
  22. software shall duly acknowledge such use, in accordance with the usual
  23. standards of acknowledging credit in academic research.
  24.  
  25. 4. MIT has made no warrantee or representation that the operation of
  26. this software will be error-free, and MIT is under no obligation to
  27. provide any services, by way of maintenance, update, or otherwise.
  28.  
  29. 5. In conjunction with products arising from the use of this material,
  30. there shall be no use of the name of the Massachusetts Institute of
  31. Technology nor of any adaptation thereof in any advertising,
  32. promotional, or sales literature without prior written consent from
  33. MIT in each case. */
  34.  
  35. /* Arithmetic Utilities */
  36.  
  37. #include "scheme.h"
  38. #include <math.h>
  39.  
  40. /* Conversions between Scheme types and C types. */
  41.  
  42. long
  43. DEFUN (fixnum_to_long, (fixnum), SCHEME_OBJECT fixnum)
  44. {
  45.   return (FIXNUM_TO_LONG (fixnum));
  46. }
  47.  
  48. SCHEME_OBJECT
  49. DEFUN (double_to_fixnum, (value), double value)
  50. {
  51. #ifdef HAVE_DOUBLE_TO_LONG_BUG
  52.   fast long temp = ((long) value);
  53.   return (LONG_TO_FIXNUM (temp));
  54. #else
  55.   return (LONG_TO_FIXNUM ((long) value));
  56. #endif
  57. }
  58.  
  59. Boolean
  60. DEFUN (integer_to_long_p, (n), fast SCHEME_OBJECT n)
  61. {
  62.   return ((FIXNUM_P (n)) || (BIGNUM_TO_LONG_P (n)));
  63. }
  64.  
  65. long
  66. DEFUN (integer_to_long,
  67.        (n),
  68.        fast SCHEME_OBJECT n)
  69. {
  70.   return ((FIXNUM_P (n)) ? (FIXNUM_TO_LONG (n)) : (bignum_to_long (n)));
  71. }
  72.  
  73. SCHEME_OBJECT
  74. DEFUN (long_to_integer, (number), long number)
  75. {
  76.   return
  77.     ((LONG_TO_FIXNUM_P (number))
  78.      ? (LONG_TO_FIXNUM (number))
  79.      : (long_to_bignum (number)));
  80. }
  81.  
  82. Boolean
  83. DEFUN (integer_to_double_p, (n), fast SCHEME_OBJECT n)
  84. {
  85.   return ((FIXNUM_P (n)) || (BIGNUM_TO_DOUBLE_P (n)));
  86. }
  87.  
  88. double
  89. DEFUN (integer_to_double, (n), fast SCHEME_OBJECT n)
  90. {
  91.   return ((FIXNUM_P (n)) ? (FIXNUM_TO_DOUBLE (n)) : (bignum_to_double (n)));
  92. }
  93.  
  94. SCHEME_OBJECT
  95. DEFUN (double_to_integer, (x), fast double x)
  96. {
  97.   return
  98.     ((DOUBLE_TO_FIXNUM_P (x))
  99.      ? (DOUBLE_TO_FIXNUM (x))
  100.      : (double_to_bignum (x)));
  101. }
  102.  
  103. double
  104. DEFUN (double_truncate, (x), fast double x)
  105. {
  106.   double iptr;
  107.   (void) modf (x, (&iptr));
  108.   return (iptr);
  109. }
  110.  
  111. /* Conversions between Scheme types and Scheme types. */
  112.  
  113. SCHEME_OBJECT
  114. DEFUN (bignum_to_fixnum, (bignum), fast SCHEME_OBJECT bignum)
  115. {
  116.   return
  117.     ((BIGNUM_TO_FIXNUM_P (bignum))
  118.      ? (BIGNUM_TO_FIXNUM (bignum))
  119.      : SHARP_F);
  120. }
  121.  
  122. SCHEME_OBJECT
  123. DEFUN (bignum_to_integer, (bignum), fast SCHEME_OBJECT bignum)
  124. {
  125.   return
  126.     ((BIGNUM_TO_FIXNUM_P (bignum))
  127.      ? (BIGNUM_TO_FIXNUM (bignum))
  128.      : bignum);
  129. }
  130.  
  131. SCHEME_OBJECT
  132. DEFUN (bignum_to_flonum, (bignum), fast SCHEME_OBJECT bignum)
  133. {
  134.   return
  135.     ((BIGNUM_TO_FLONUM_P (bignum))
  136.      ? (BIGNUM_TO_FLONUM (bignum))
  137.      : SHARP_F);
  138. }
  139.  
  140. Boolean
  141. DEFUN (flonum_integer_p, (x), SCHEME_OBJECT x)
  142. {
  143.   extern double EXFUN (modf, (double, double *));
  144.   double iptr;
  145.   return ((modf ((FLONUM_TO_DOUBLE (x)), (&iptr))) == 0);
  146. }
  147.  
  148. SCHEME_OBJECT
  149. DEFUN (flonum_floor, (x), SCHEME_OBJECT x)
  150. {
  151.   extern double EXFUN (floor, (double));
  152.   return (double_to_flonum (floor (FLONUM_TO_DOUBLE (x))));
  153. }
  154.  
  155. SCHEME_OBJECT
  156. DEFUN (flonum_ceiling, (x), SCHEME_OBJECT x)
  157. {
  158.   extern double EXFUN (ceil, (double));
  159.   return (double_to_flonum (ceil (FLONUM_TO_DOUBLE (x))));
  160. }
  161.  
  162. SCHEME_OBJECT
  163. DEFUN (flonum_round,
  164.        (x),
  165.        SCHEME_OBJECT x)
  166. {
  167.   fast double dx = (FLONUM_TO_DOUBLE (x));
  168.   return
  169.     (double_to_flonum (double_truncate ((dx < 0) ? (dx - 0.5) : (dx + 0.5))));
  170. }
  171.  
  172. SCHEME_OBJECT
  173. DEFUN (flonum_normalize, (x), SCHEME_OBJECT x)
  174. {
  175.   extern double EXFUN (frexp, (double, int *));
  176.   int exponent;
  177.   double significand = (frexp ((FLONUM_TO_DOUBLE (x)), (&exponent)));
  178.   return (cons ((double_to_flonum (significand)),
  179.         (long_to_integer ((long) exponent))));
  180. }
  181.  
  182. SCHEME_OBJECT
  183. DEFUN (flonum_denormalize, (x, e), SCHEME_OBJECT x AND SCHEME_OBJECT e)
  184. {
  185.   extern double EXFUN (ldexp, (double, int));
  186.   return (double_to_flonum (ldexp ((FLONUM_TO_DOUBLE (x)),
  187.                    ((int) (integer_to_long (e))))));
  188. }
  189.  
  190. /* Generic Integer Operations */
  191.  
  192. Boolean
  193. DEFUN (integer_zero_p, (n), SCHEME_OBJECT n)
  194. {
  195.   return ((FIXNUM_P (n)) ? (FIXNUM_ZERO_P (n)) : (BIGNUM_ZERO_P (n)));
  196. }
  197.  
  198. Boolean
  199. DEFUN (integer_negative_p, (n), SCHEME_OBJECT n)
  200. {
  201.   return ((FIXNUM_P (n)) ? (FIXNUM_NEGATIVE_P (n)) : (BIGNUM_NEGATIVE_P (n)));
  202. }
  203.  
  204. Boolean
  205. DEFUN (integer_positive_p, (n), SCHEME_OBJECT n)
  206. {
  207.   return ((FIXNUM_P (n)) ? (FIXNUM_POSITIVE_P (n)) : (BIGNUM_POSITIVE_P (n)));
  208. }
  209.  
  210. Boolean
  211. DEFUN (integer_equal_p, (n, m), SCHEME_OBJECT n AND SCHEME_OBJECT m)
  212. {
  213.   return
  214.     ((FIXNUM_P (n))
  215.      ? ((FIXNUM_P (m))
  216.     ? (FIXNUM_EQUAL_P (n, m))
  217.     : (bignum_equal_p ((FIXNUM_TO_BIGNUM (n)), m)))
  218.      : (bignum_equal_p (n, ((FIXNUM_P (m)) ? (FIXNUM_TO_BIGNUM (m)) : m))));
  219. }
  220.  
  221. Boolean
  222. DEFUN (integer_less_p, (n, m), SCHEME_OBJECT n AND SCHEME_OBJECT m)
  223. {
  224.   return
  225.     ((FIXNUM_P (n))
  226.      ? ((FIXNUM_P (m))
  227.     ? (FIXNUM_LESS_P (n, m))
  228.     : (BIGNUM_LESS_P ((FIXNUM_TO_BIGNUM (n)), m)))
  229.      : (BIGNUM_LESS_P (n, ((FIXNUM_P (m)) ? (FIXNUM_TO_BIGNUM (m)) : m))));
  230. }
  231.  
  232. SCHEME_OBJECT
  233. DEFUN (integer_negate, (n), SCHEME_OBJECT n)
  234. {
  235.   return
  236.     ((FIXNUM_P (n))
  237.      ? (long_to_integer (- (FIXNUM_TO_LONG (n))))
  238.      : (bignum_to_integer (bignum_negate (n))));
  239. }
  240.  
  241. SCHEME_OBJECT
  242. DEFUN (integer_add, (n, m), SCHEME_OBJECT n AND SCHEME_OBJECT m)
  243. {
  244.   return
  245.     ((FIXNUM_P (n))
  246.      ? ((FIXNUM_P (m))
  247.     ? (long_to_integer ((FIXNUM_TO_LONG (n)) + (FIXNUM_TO_LONG (m))))
  248.     : (bignum_to_integer (bignum_add ((FIXNUM_TO_BIGNUM (n)), m))))
  249.      : (bignum_to_integer
  250.     (bignum_add (n, ((FIXNUM_P (m)) ? (FIXNUM_TO_BIGNUM (m)) : m)))));
  251. }
  252.  
  253. SCHEME_OBJECT
  254. DEFUN (integer_add_1, (n), SCHEME_OBJECT n)
  255. {
  256.   return
  257.     ((FIXNUM_P (n))
  258.      ? (long_to_integer ((FIXNUM_TO_LONG (n)) + 1))
  259.      : (bignum_to_integer (bignum_add (n, (long_to_bignum (1))))));
  260. }
  261.  
  262. SCHEME_OBJECT
  263. DEFUN (integer_subtract, (n, m), SCHEME_OBJECT n AND SCHEME_OBJECT m)
  264. {
  265.   return
  266.     ((FIXNUM_P (n))
  267.      ? ((FIXNUM_P (m))
  268.     ? (long_to_integer ((FIXNUM_TO_LONG (n)) - (FIXNUM_TO_LONG (m))))
  269.     : (bignum_to_integer (bignum_subtract ((FIXNUM_TO_BIGNUM (n)), m))))
  270.      : (bignum_to_integer
  271.     (bignum_subtract (n, ((FIXNUM_P (m)) ? (FIXNUM_TO_BIGNUM (m)) : m)))));
  272. }
  273.  
  274. SCHEME_OBJECT
  275. DEFUN (integer_subtract_1, (n), SCHEME_OBJECT n)
  276. {
  277.   return
  278.     ((FIXNUM_P (n))
  279.      ? (long_to_integer ((FIXNUM_TO_LONG (n)) - 1))
  280.      : (bignum_to_integer (bignum_subtract (n, (long_to_bignum (1))))));
  281. }
  282.  
  283. SCHEME_OBJECT
  284. DEFUN (integer_multiply, (n, m), SCHEME_OBJECT n AND SCHEME_OBJECT m)
  285. {
  286.   extern SCHEME_OBJECT EXFUN (Mul, (SCHEME_OBJECT, SCHEME_OBJECT));
  287.   fast SCHEME_OBJECT result;
  288.   return
  289.     ((FIXNUM_P (n))
  290.      ? ((FIXNUM_P (m))
  291.     ? ((result = (Mul (n, m))),
  292.        ((result != SHARP_F)
  293.         ? result
  294.         : (bignum_to_integer
  295.            (bignum_multiply ((FIXNUM_TO_BIGNUM (n)),
  296.                  (FIXNUM_TO_BIGNUM (m)))))))
  297.     : (bignum_to_integer (bignum_multiply ((FIXNUM_TO_BIGNUM (n)), m))))
  298.      : (bignum_to_integer
  299.     (bignum_multiply (n, ((FIXNUM_P (m)) ? (FIXNUM_TO_BIGNUM (m)) : m)))));
  300. }
  301.  
  302. Boolean
  303. DEFUN (integer_divide, (n, d, q, r),
  304.        SCHEME_OBJECT n AND SCHEME_OBJECT d
  305.        AND SCHEME_OBJECT * q AND SCHEME_OBJECT * r)
  306. {
  307.   if (FIXNUM_P (n))
  308.     {
  309.       if (FIXNUM_P (d))
  310.     {
  311.       /* Now, unbelievable hair because C doesn't fully specify
  312.          / and % when their arguments are negative.  We must get
  313.          consistent answers for all valid arguments. */
  314.       fast long lx = (FIXNUM_TO_LONG (n));
  315.       fast long ly = (FIXNUM_TO_LONG (d));
  316.       fast long quotient;
  317.       fast long remainder;
  318.       if (ly == 0)
  319.         return (true);
  320.       if (lx < 0)
  321.         {
  322.           lx = (-lx);
  323.           if (ly < 0)
  324.         {
  325.           ly = (-ly);
  326.           quotient = (lx / ly);
  327.         }
  328.           else
  329.         quotient = (- (lx / ly));
  330.           remainder = (- (lx % ly));
  331.         }
  332.       else
  333.         {
  334.           if (ly < 0)
  335.         {
  336.           ly = (-ly);
  337.           quotient = (- (lx / ly));
  338.         }
  339.           else
  340.         quotient = (lx / ly);
  341.           remainder = (lx % ly);
  342.         }
  343.       (*q) = (long_to_integer (quotient));
  344.       (*r) = (LONG_TO_FIXNUM (remainder));
  345.       return (false);
  346.     }
  347.       n = (FIXNUM_TO_BIGNUM (n));
  348.     }
  349.   else
  350.     {
  351.       if (FIXNUM_P (d))
  352.     d = (FIXNUM_TO_BIGNUM (d));
  353.     }
  354.   {
  355.     SCHEME_OBJECT quotient;
  356.     SCHEME_OBJECT remainder;
  357.     if (bignum_divide (n, d, ("ient), (&remainder)))
  358.       return (true);
  359.     (*q) = (bignum_to_integer (quotient));
  360.     (*r) = (bignum_to_integer (remainder));
  361.     return (false);
  362.   }
  363. }
  364.  
  365. SCHEME_OBJECT
  366. DEFUN (integer_quotient, (n, d), SCHEME_OBJECT n AND SCHEME_OBJECT d)
  367. {
  368.   if (FIXNUM_P (n))
  369.     {
  370.       if (FIXNUM_P (d))
  371.     {
  372.       fast long lx = (FIXNUM_TO_LONG (n));
  373.       fast long ly = (FIXNUM_TO_LONG (d));
  374.       return
  375.         ((ly == 0)
  376.          ? SHARP_F
  377.          : (long_to_integer
  378.         ((lx < 0)
  379.          ? ((ly < 0)
  380.             ? ((-lx) / (-ly))
  381.             : (- ((-lx) / ly)))
  382.          : ((ly < 0)
  383.             ? (- (lx / (-ly)))
  384.             : (lx / ly)))));
  385.     }
  386.       n = (FIXNUM_TO_BIGNUM (n));
  387.     }
  388.   else
  389.     {
  390.       if (FIXNUM_P (d))
  391.     d = (FIXNUM_TO_BIGNUM (d));
  392.     }
  393.   {
  394.     SCHEME_OBJECT result = (bignum_quotient (n, d));
  395.     return
  396.       ((result == SHARP_F)
  397.        ? SHARP_F
  398.        : (bignum_to_integer (result)));
  399.   }
  400. }
  401.  
  402. SCHEME_OBJECT
  403. DEFUN (integer_remainder, (n, d), SCHEME_OBJECT n AND SCHEME_OBJECT d)
  404. {
  405.   if (FIXNUM_P (n))
  406.     {
  407.       if (FIXNUM_P (d))
  408.     {
  409.       fast long lx = (FIXNUM_TO_LONG (n));
  410.       fast long ly = (FIXNUM_TO_LONG (d));
  411.       return
  412.         ((ly == 0)
  413.          ? SHARP_F
  414.          : (long_to_integer
  415.         ((lx < 0)
  416.          ? (- ((-lx) % ((ly < 0) ? (-ly) : ly)))
  417.          : (lx % ((ly < 0) ? (-ly) : ly)))));
  418.     }
  419.       n = (FIXNUM_TO_BIGNUM (n));
  420.     }
  421.   else
  422.     {
  423.       if (FIXNUM_P (d))
  424.     d = (FIXNUM_TO_BIGNUM (d));
  425.     }
  426.   {
  427.     SCHEME_OBJECT result = (bignum_remainder (n, d));
  428.     return
  429.       ((result == SHARP_F)
  430.        ? SHARP_F
  431.        : (bignum_to_integer (result)));
  432.   }
  433. }
  434.